cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                              cc
cc           pmtexa.for Version 1.0     2-18-95                 cc
cc                                                              cc
cc   A production of Dr. Don's PC and Harpsichord Emporium      cc
cc        Don Simons (dsimons@logicon.com), proprietor          cc
cc   "An imaginary gathering place for technoid pluckheads"     cc
cc                                                              cc
cc   This is no-ware: No cost, no license, no guarantee         cc
cc                                                              cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      logical loop
      integer nn(5),list(4,200),ipl(5,200),nodur(5,200),
     *        nnl(5),itsofar(5),nib(5,15),nask(0:200),lastbar(0:30),
     *        nbarss(30)
      real*4 elsk(200),celsk(0:200),elperbar(30)
      character*80 line
      character*1 acc(5,200)
      character*24 basename,iname(5)
      logical rest(5,200),firstline
      common /comget/ lastchar
      logical lastchar
      common /all/ iv,list,nnl,nv,ibar,ipl,
     *   nodur,jn,lenbar,iccount,nbars,itsofar,nib,nn,
     *   rest,lenbar0,lenbar1,firstline
      common /all/ acc
      common /linecom/ elskl,elskb,naskb
      lastchar = .false.
c
c  iccount: pointer in string from input file.  Just before calling getchar,
c          it points to the last character retrieved. 
c  nnl    : # of notes in a line (//)
c  itsofar: time in current line from start of line
c
c  The following 6 cc commented lines get the basename as a command line
c  argument.  Since they probably only work in Microsoft FORTRAN, I've 
c  replaced them (in the next 2 lines) with a more generic prompt for 
c  inputting the base name.
c  
cc    if (nargs() .ne. 2) then
cc      print*,
cc   *   'There should only be one command line argument!  Try again.'
cc      stop
cc    end if
cc    call getarg(1,basename,lbase)
      print*,'Please type a basename (<9 characters, no dots): '
      read(*,'(a)')basename  
      if (index(basename,'.') .ne. 0) then
        print*,'Do not include extension in basename. Try again.'
        stop
      end if
      lbase = index(basename,' ')-1
      data sfact,widthpt,iwaskpt,fsyst,fbar,wtimesig,vsizi
     *   /   2. , 524.  ,   3   , 0.25,0.18,  10.   , 680./ 
      open(10,file=basename(1:lbase)//'.inp')
      read(10,*)nv,noinst,mtrnum,mtrden,imeter,xmtrnum0,isig,
     *          lpp,nstaves,musicsize,fracindent
      do 6 iv = 1 , nv
        read(10,'(a)')iname(iv)
6     continue
      read(10,'(a80)')line
      read(10,'(a80)')line
      lpath = index(line,' ')-1
      if (line(lpath:lpath).ne.'/'.and.
     *    line(lpath:lpath).ne.char(92)) then
        print*,
     *   'Last character of pathname is neither / nor '//char(92)//' .'
        print*,'Do you want to continue? ("y" to continue)'
        read(*,'(a)')line
        if (line(1:1).ne.'y' .and. line(1:1).ne.'Y') stop
      end if
      open(12,file='pmtex.dat')
      write(12,'(a)')basename(1:lbase)
      write(12,*)lbase
      ifig = 0
      lenbeat = ifnodur(mtrden,'x')
      lenbar1 = mtrnum*lenbeat
      lenbar0 = xmtrnum0*lenbeat+.1
      if (lenbar0 .ne. 0) then
        ibaroff = 1
        lenbar = lenbar0
      else
        ibaroff = 0
        lenbar = lenbar1
      end if
c
c Vertical analysis.  ixxxfacteur is space in \Interligne's. Page ht (pt) is
c    (musicsize)/4*lpp*(itop+ibot+4+interf*(nv-1)).
c    Assume itop=ibot and itop+ibot=sfact*(interf-4), where sfact is input. 
c
      itopfacteur=(vsizi/lpp/(musicsize/4.)-4*nv)/2/(1+(nv-1)/sfact)+.5
      ibotfacteur = itopfacteur
      interfacteur = (ibotfacteur+itopfacteur)/sfact+4.5
      write(12,*)itopfacteur,ibotfacteur,interfacteur 
      ibarcnt = 0
      iccount = 80
c
c  Initialize for loop over lines
c
      firstline = .true.
30    loop = .true.
      nbars = 0
3     do 4 iv = 1 , nv
        itsofar(iv) = 0
        nnl(iv) = 0
        do 5 j = 1 , 200
          rest(iv,j) = .false.
          acc(iv,j) = 'x'
5       continue
4     continue 
      iv = 1
2     if (loop) then
c
c  Within this loop, nv voices are filled up for the duration of the line.
c  On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv)
c  nolev(nv,nnl(nv)),nodur(..),acc(..),rest(..).  nnl will later be
c  increased and things slid around as accidental skips are added.  
c
        call getnote(loop,ifig) 
        if (lastchar) go to 20
        go to 2
      end if
      firstline = .false.
      elskl = 0.
      do 10 ibar = 1 , nbars
        ibarcnt = ibarcnt+1
        print*,'Now processing bar #',ibarcnt-ibaroff
        lenbar = lenbar1
        if (lenbar0.ne.0 .and. ibarcnt.eq.1) lenbar = lenbar0
        if (ibar .gt. 1) then
c
c  For bars after first, slide all stuff down to beginning of arrays
c
          do 11 iv = 1 , nv
            ioff = nib(iv,ibar-1)
            do 12 ip = 1 , nib(iv,ibar)-ioff
              nodur(iv,ip) = nodur(iv,ip+ioff)
              acc(iv,ip) = acc(iv,ip+ioff)
              rest(iv,ip) = rest(iv,ip+ioff)
12          continue
11        continue
        end if
        call makeabar()
        elsk(ibarcnt) = elskb
        nask(ibarcnt) = naskb 
10    continue
      go to 30
20    continue
      celsk(1) = elsk(1)
      do 21 ibar = 2 , ibarcnt
        celsk(ibar) = celsk(ibar-1)+elsk(ibar)
21    continue
      nask(0) = 0
      lastbar(0) = 0
      do 22 istaff = 1 , nstaves
        ibarb4 = lastbar(istaff-1)
        if (istaff .eq. 1) then
          elsstarg = celsk(ibarcnt)/(nstaves-fracindent)
          celskb4 = 0.
        else
          celskb4 = celsk(ibarb4)
          elsstarg = (celsk(ibarcnt)-celskb4)/(nstaves-istaff+1)
        end if
        diff1 = abs(elsstarg-elsk(ibarb4+1))
        do 23 ibar = ibarb4+2 , ibarcnt
          diff = elsstarg-(celsk(ibar)-celskb4)
          if (abs(diff) .ge. diff1) go to 24
          diff1 = abs(diff)
23      continue 
24      ibar = ibar-1
        lastbar(istaff) = ibar
        nbarss(istaff) = ibar-ibarb4
        elss = celsk(ibar)-celskb4
        elperbar(istaff) = elss/(ibar-ibarb4)
        if (istaff.eq.1.) elperbar(1) = elperbar(1)/(1-fracindent)
        write(12,'(i5)')lastbar(istaff-1)+1
c
c   Count up accidental skips
c
        numask = 0
        do 25 ibr = ibarb4+1, lastbar(istaff)
          numask = numask+nask(ibr)
25      continue
        ielperbar = elperbar(istaff)
c
c   Check width this would give
c
26      welsk = ((widthpt-fsyst*musicsize)/nbarss(istaff)
     *      -fbar*musicsize)/ielperbar
        wten = welsk*elss 
        finow = 0.
        if (istaff.eq.1) finow = fracindent
        wavail = widthpt*(1-finow)-numask*iwaskpt
        if (istaff .eq. 1) wavail = wavail-wtimesig
        if (wavail .lt. wten) then
          ielperbar = ielperbar+1
          go to 26
        end if
        write(12,'(a7,i2,a2,i2,a2,i2,a1)')
     *     char(92)//'autol{',ielperbar,'}{',nbarss(istaff),
     *       '}{',lpp,'}%'
22    continue
      write(12,'(i5)')0
      open(13,file='pmtex.fig')
      write(13,'(i5)')ifig
      close(12)
      close(13)
      print*,'Done with first pass.  Now run pmTeXb.'
      end
      subroutine getnote(loop,ifig)
      common /all/ iv,list(4,200),nnl(5),nv,ibar,
     *   ipl(5,200),
     *   nodur(5,200),jn,lenbar,iccount,nbars,itsofar(5),
     *   nib(5,15),nn(5),
     *   rest(5,200),lenbar0,lenbar1,firstline
      common /all/ acc(5,200)
      common /comget/ lastchar
      logical lastchar,firstline
      character*1 acc
      logical rest
      character*80 line
      logical loop
      character*1 char,oct,dot,dum
1     call getchar(line,iccount,char)
      if (lastchar) return
      if (char .eq. ' ') then
        go to 1
      else if (char .eq. '%') then
        iccount = 80
        go to 1
      else if (ichar(char).ge.97 .and. ichar(char).le.103) then
c
c This is a note.  Increase note count, get octave & basic duration.
c
        nnl(iv) = nnl(iv)+1
        call getchar(line,iccount,oct)
      if (lastchar) return
        dot = 'x'
        if (oct .ne. ' ') then
          read(oct,'(i1)')ioct
          call getchar(line,iccount,char)
      if (lastchar) return
        else
c#### Get octave from previous one
          char = ' '
        end if 
        if (char .eq. ' ') then
          nodur(iv,nnl(iv)) = nodur(iv,nnl(iv)-1)
          go to 4
        end if
        read(char,'(i1)')inodur
2       call getchar(line,iccount,char)
      if (lastchar) return
        if (char .ne. ' ') then
          if (char .eq. 'd') then
            dot = char
          else if (char .eq. '/') then
            continue
          else
c
c  Only other possibility is an accidental
c
            acc(iv,nnl(iv)) = char
          end if
          if (char .ne. '/') go to 2
        end if
        nodur(iv,nnl(iv)) = ifnodur(inodur,dot)
4       itsofar(iv) = itsofar(iv)+nodur(iv,nnl(iv))
        if (mod(itsofar(iv),lenbar) .eq. 0) then
          nbars = nbars+1
          nib(iv,nbars) = nnl(iv)
          if (lenbar .ne. lenbar1) then
c
c###  Just finished the pickup bar for this voice.
c
            lenbar = lenbar1
            itsofar(iv) = 0
          end if
        end if 
      else if (char .eq. 'o') then
c###             "o" symbol must come AFTER the affected note
        call getchar(line,iccount,dum) 
        if (lastchar) return
      else if ((ichar(char).ge.49.and.ichar(char).le.57) .or.
     *    char.eq.'#' .or. char.eq.'-' .or. char.eq.'n'
     *    .or. char.eq.'_') then
c###            We have a figure.  Must come AFTER the note it goes under
5       call getchar(line,iccount,char)
        ifig = 1
        if (lastchar) return
        if (char .ne. ' ') then
          go to 5
        end if
      else if (char .eq. 'r') then
c
c  We have a rest, so get inodur and dot
c
        nnl(iv) = nnl(iv) + 1
        rest(iv,nnl(iv)) = .true.
        call getchar(line,iccount,char)
      if (lastchar) return
        read(char,'(i1)')inodur
        dot = 'x'
        call getchar(line,iccount,char)
      if (lastchar) return
        if (char .eq. 'd') then
          dot = char
        end if 
        nodur(iv,nnl(iv)) = ifnodur(inodur,dot)
        itsofar(iv) = itsofar(iv)+nodur(iv,nnl(iv))
        if (mod(itsofar(iv),lenbar) .eq. 0) then
          nbars = nbars+1
          nib(iv,nbars) = nnl(iv)
          if (lenbar .ne. lenbar1) then
c
c###  Just finished the pickup bar for this voice
c
            lenbar = lenbar1
            itsofar(iv) = 0
          end if
        end if 
      end if
3     if (char .eq. '/') then
c
c  Start a new voice for this line
c
        if (iv .eq. 1) then
          if (mod(itsofar(iv),lenbar) .ne. 0) then
            print*,'Beats in 1st voice not divisible by barlength'
            stop
          end if
        else if (itsofar(iv) .ne. itsofar(1)) then
          print*,'Error in timing, voice',iv
          stop
        end if
        if (iv .eq. nv) then
          loop = .false.
        else
          nbars = 0
          iv = iv+1
          if (lenbar0.ne.0 .and. firstline) lenbar = lenbar0
        end if
      end if
      return
      end
      subroutine getchar(line,iccount,char)
      common /comget/ lastchar
      logical lastchar
c
c  Gets the next character out of line*80.  If pointer iccount=80 on entry,
c  then reads in a new line.  Resets iccount.  Ends program if no more input.  
c
      character*1 char 
      character*80 line
      if (iccount .eq. 80) then
        read(10,'(a80)',end=999)line
        iccount = 0
      end if
      iccount = iccount+1
      char = line(iccount:iccount)
      return
999   continue
      lastchar = .true.
      return
      end
      function log2(n)
        log2 = alog(n*1.)/0.69315+.01
      return
      end
      function ifnodur(idur,dot)
        character*1 dot
        if(idur .eq. 3)then
          ifnodur=3
        else if(idur .eq. 1) then
          ifnodur=6 
        else if(idur .eq. 8) then
          ifnodur=12 
        else if(idur .eq. 4) then
          ifnodur=24 
        else if(idur .eq. 2) then
          ifnodur=48
        else if(idur .eq. 0) then
          ifnodur=96
        else 
          print*,'You entered an invalid note-length value'
          stop
        end if
        if (dot .eq. 'd') ifnodur = ifnodur*1.5+.5
      return
      end
      subroutine makeabar()
      common /all/ iv,list(4,200),nnl(5),nv,ibar,
     *   ipl(5,200),
     *   nodur(5,200),jn,lenbar,iccount,nbars,itsofar(5),
     *   nib(5,15),nn(5),
     *   rest(5,200),lenbar0,lenbar1,firstline
      common /all/ acc(5,200)
      common /linecom/ elskl,elskb,naskb
      character*1 acc
      logical rest,firstline
      integer it(5),cnn(5),istart(20),istop(20),itstart(20),
     *   nspace(20),nindex(20)
      elskb = 0.
      naskb = 0
      do 1 iv = 1 , nv
        if (ibar .gt. 1) then
          nn(iv) = nib(iv,ibar)-nib(iv,ibar-1)
        else
          nn(iv) = nib(iv,ibar)
        end if
1     continue
c
c initialize list note counter, time(iv), curr. note(iv)
c
      ilnc = 1
      do 4 iv = 1 , nv
        if (nn(iv) .gt. 1) then
          it(iv) = nodur(iv,1)
        else
          it(iv) = 1000
        end if
        cnn(iv) = 1
        list(1,ilnc) = iv
        list(2,ilnc) = 1
        ilnc = ilnc+1
4     continue
c
c  Build the list
c
5     continue
c
c  Determine which voice comes next from end of notes done so far.
c  itmin is the earliest ending time of notes done so far
c
      itmin = 1000
      do 6 iv = 1 , nv
        itminn = min(itmin,it(iv))
        if(itminn .lt. itmin) then
          itmin = itminn
          ivnext = iv
        end if
6     continue
      if (itmin .eq. 1000) go to 7
      list(1,ilnc) = ivnext
      cnn(ivnext) = cnn(ivnext)+1
      list(2,ilnc) = cnn(ivnext) 
      list(3,ilnc) = itmin
c
c  Check if this voice is done
c           
      if (cnn(ivnext) .eq. nn(ivnext)) then
        it(ivnext) = 1000
      else
        it(ivnext) = it(ivnext)+nodur(ivnext,cnn(ivnext)) 
      end if
      ilnc = ilnc+1
      go to 5
7     continue
      ntot = ilnc-1
      do 8 in = 1 , ntot-1
        list(4,in) = list(3,in+1)-list(3,in)
8     continue
      list(4,ntot) = nodur(list(1,ntot),list(2,ntot))
c
c  Done w/ list, but for special checks. First, for full-bar rests
c
      do 30 iv = 1 , nv
        if (nodur(iv,1).eq.lenbar.and.rest(iv,1).and.ntot.gt.nv) then
c
c  Find the last list position (in) before the half-bar
c
          do 31 in = 1 , ntot-1
            if (list(3,in+1) .ge. lenbar/2) go to 32
31        continue
          print*,'Mess-up looking for half-bar'
          stop
32        itwrest = list(3,in)
c
c  Backup to spot for inserting rest marker, i.e., one to the right of 
c  the first place where either list(1)<iv or list(3)<itwrest 
c
          do 33 iin = in-1 , 1 , -1
            if(list(1,iin).lt.iv.or.list(3,iin).lt.itwrest)go to 34
33        continue
          print*,'Problem backing up from half bar'
c         stop
34        infr = iin+1
          call add2list(infr,2,itwrest,lenbar-itwrest,'w',.true.,
     *     ntot,istart,istop,nb)
          nodur(iv,1) = itwrest
          acc(iv,1) = 'b'
        end if
30    continue  
c
c  A kluged up loop for building note blocks:
c
      ib = 1 
      istart(1) = 1
      nspace(1) = 0
      in = 1 
9     continue
        if (in .eq. ntot) then
          if (nspace(ib) .eq. 0) nspace(ib)=list(4,in)
          istop(ib) = ntot
c Now we flow out of this if and into block-building      
        else if (nspace(ib) .eq. 0) then
c nspace hasn't been set yet, so 
c and tentatively set:
          nspace(ib) = list(4,in)
          if (nspace(ib) .eq. 0) then
            in=in+1
          else
            istop(ib) = in
          end if
          go to 9
        else if (list(4,in+1) .eq. 0) then
c This is not the last note in the group, so
          in = in+1
          go to 9 
        else if (list(4,in+1) .eq. nspace(ib)) then
c Keep spacing the same, update tentative stop point
          in = in+1
          istop(ib) = in
          go to 9
        end if
c
c At this point istart and istop are good, so on to next block 
c
        itstart(ib) = list(3,istart(ib))
        nindex(ib) = log2(nspace(ib)/2)+1
        elsperns = 2.**((nindex(ib)-1)/2.)
        if (istop(ib) .eq. ntot) then
          nnsk = (lenbar-itstart(ib))/nspace(ib)
          elskl = elskl+elsperns*nnsk
          elskb = elskb+elsperns*nnsk
          go to 15
        end if
        nnsk = (list(3,istop(ib)+1)-itstart(ib))/nspace(ib)
        elskl = elskl+elsperns*nnsk
        elskb = elskb+elsperns*nnsk
        ib = ib+1
        istart(ib) = istop(ib-1)+1
        in = istart(ib)
c
c Set tentative block space for new block
c
        nspace(ib) = list(4,in)
        istop(ib) = in
      go to 9          
15    continue
      nb = ib
c
c  Now add to list special codes for accidental skips.  This is a loop on
c  in up to ntot, but ntot increases when a skip is added, so loop manually
c  Must bypass this loop if all there are are whole rests.
      if (ntot .eq. nv) go to 40
      in = 2
39    continue
        jv = list(1,in)
        ip = list(2,in)
        itim = list(3,in)
        if ((acc(jv,ip).eq.'f' .or. acc(jv,ip).eq.'n'
     *      .or. acc(jv,ip).eq.'s') .and. nodur(jv,ip-1).le.6 .and.
     *       ip.ge.2 .and. acc(jv,ip-1).ne.'a') then
c         print*,'I got into ask zone!!!'
          naskb = naskb+1
c
c  Need accidental skip. Find block # for list position "in".
c
          do 45 ib = 1 , nb
            if (istop(ib) .ge. in) go to 46
45        continue
          print*,'Got lost looking for ib!!'
46        continue
          do 42 iv = nv , 1 , -1
            if (iv .eq. jv) then
              iip = ip
              iin = in
              iitim = itim
            else if (nn(iv) .eq. 1) then
              go to 42
            else
c 
c  Find ip# for this voice at this itim !!!  
c
              do 43 iin = 2 , ntot
                if (list(1,iin).eq.iv.and.list(3,iin).ge.itim)then
c
c  Check if in the same block as the offending accidental
c
                  if (istop(ib) .ge. iin) go to 44
c
c  Note is in next block, so no skip needed.
c
                  go to 42
                end if
43            continue
c
c No skip needed, since no new notes after the one in question, so
c
              go to 42
44            iip = list(2,iin)
              iitim = list(3,iin)
            end if
            call add2list(iin,iip,iitim,0,'a',.true.,ntot,
     *         istart,istop,nb)
42        continue
        end if
      if (in .eq. ntot) go to 40 
      in = in+1
      go to 39
40    continue              
c
c  Invert the list of places, to make it easier to analyze a voice
c
      do 13 in = 1 , ntot
        ipl(list(1,in),list(2,in)) = in
13    continue 
      return
      end
      subroutine add2list(infr,newip,newstrt,newdur,newacc,newrest,
     *     ntot,istart,istop,nb)
c
c  This inserts into the list a new "note" at location infr.  Inputs vars are
c     (iv) = voice # (in common)
c     newip = position in voice, from beginning of bar
c     newstrt = starting time of new "note"
c     newdur =  duration
c     newacc = accidental value
c     newrest = rest value
c     
      common /all/ iv,list(4,200),nnl(5),nv,ibar,
     *   ipl(5,200),
     *   nodur(5,200),jn,lenbar,iccount,nbars,itsofar(5),
     *   nib(5,15),nn(5),
     *   rest(5,200),lenbar0,lenbar1,firstline
      common /all/ acc(5,200)
      character*1 acc
      logical rest,firstline
        character*1 newacc
        logical newrest
        integer istart(20),istop(20)
c
c  Move everything in the list to the right by one spot, and adjust ip
c    for notes in affected voice.
c
        do 34 in = ntot , infr , -1
          if (list(1,in).eq.iv) list(2,in) = list(2,in)+1
          do 35 il = 1 , 4
            list(il,in+1) = list(il,in)
35        continue
34      continue
c
c  Move everything in nodur,rest,acc,nolev to the right by one 
c
        do 36 ip = nnl(iv) , newip , -1
          nodur(iv,ip+1) = nodur(iv,ip)
          acc(iv,ip+1) = acc(iv,ip)
          rest(iv,ip+1) = rest(iv,ip)
36      continue
        nnl(iv) = nnl(iv)+1
        do 37 iibar = ibar , nbars 
          nib(iv,iibar) = nib(iv,iibar)+1
37      continue
        ntot = ntot+1
        nn(iv) = nn(iv)+1
        nodur(iv,newip) = newdur
        rest(iv,newip) = newrest
        acc(iv,newip) = newacc
        list(1,infr) = iv
        list(2,infr) = newip
        list(3,infr) = newstrt
        list(4,infr) = list(3,infr+1)-list(3,infr)
        list(4,infr-1) = list(3,infr)-list(3,infr-1)
c
c Check the note blocks
c
        do 38 ib = 1 , nb
          if (infr .le. istop(ib)) istop(ib) = istop(ib)+1
          if (infr .lt. istart(ib)) istart(ib) = istart(ib)+1
38      continue            
      return
      end
